home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-pop.el.z / vm-pop.el
Encoding:
Text File  |  1998-05-21  |  25.4 KB  |  719 lines
  1. ;;; Simple POP (RFC 1939) client for VM
  2. ;;; Copyright (C) 1993, 1994, 1997, 1998 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-pop)
  19.  
  20. (if (fboundp 'define-error)
  21.     (progn
  22.       (define-error 'vm-cant-uidl "Can't use UIDL")
  23.       (define-error 'vm-dele-failed "DELE command failed")
  24.       (define-error 'vm-uidl-failed "UIDL command failed"))
  25.   (put 'vm-cant-uidl 'error-conditions '(vm-cant-uidl error))
  26.   (put 'vm-cant-uidl 'error-message "Can't use UIDL")
  27.   (put 'vm-dele-failed 'error-conditions '(vm-dele-failed error))
  28.   (put 'vm-dele-failed 'error-message "DELE command failed")
  29.   (put 'vm-uidl-failed 'error-conditions '(vm-uidl-failed error))
  30.   (put 'vm-uidl-failed 'error-message "UIDL command failed"))
  31.  
  32. ;; Our goal is to drag the mail from the POP maildrop to the crash box.
  33. ;; just as if we were using movemail on a spool file.
  34. ;; We remember which messages we have retrieved so that we can
  35. ;; leave the message in the mailbox, and yet not retrieve the
  36. ;; same messages again and again.
  37. (defun vm-pop-move-mail (source destination)
  38.   (let ((process nil)
  39.     (folder-type vm-folder-type)
  40.     (m-per-session vm-pop-messages-per-session)
  41.     (b-per-session vm-pop-bytes-per-session)
  42.     (handler (and (fboundp 'find-file-name-handler)
  43.               (condition-case ()
  44.               (find-file-name-handler source 'vm-pop-move-mail)
  45.             (wrong-number-of-arguments
  46.               (find-file-name-handler source)))))
  47.     (popdrop (vm-safe-popdrop-string source))
  48.     (statblob nil)
  49.     (can-uidl t)
  50.     (auto-expunge (or vm-pop-expunge-after-retrieving
  51.               (cdr (assoc source vm-pop-auto-expunge-alist))
  52.               (cdr (assoc (vm-popdrop-sans-password source)
  53.                       vm-pop-auto-expunge-alist))))
  54.     (msgid (list nil (vm-popdrop-sans-password source) 'uidl))
  55.     (pop-retrieved-messages vm-pop-retrieved-messages)
  56.     mailbox-count mailbox-size message-size response
  57.     n retrieved retrieved-bytes process-buffer uidl)
  58.     (unwind-protect
  59.     (catch 'done
  60.       (if handler
  61.           (throw 'done
  62.              (funcall handler 'vm-pop-move-mail source destination)))
  63.       (setq process (vm-pop-make-session source))
  64.       (or process (throw 'done nil))
  65.       (setq process-buffer (process-buffer process))
  66.       (save-excursion
  67.         (set-buffer process-buffer)
  68.         (setq vm-folder-type (or folder-type vm-default-folder-type))
  69.         ;; find out how many messages are in the box.
  70.         (vm-pop-send-command process "STAT")
  71.         (setq response (vm-pop-read-stat-response process)
  72.           mailbox-count (nth 0 response)
  73.           mailbox-size (nth 1 response))
  74.         ;; forget it if the command fails
  75.         ;; or if there are no messages present.
  76.         (if (or (null mailbox-count)
  77.             (< mailbox-count 1))
  78.         (throw 'done nil))
  79.         ;; loop through the maildrop retrieving and deleting
  80.         ;; messages as we go.
  81.         (setq n 1 retrieved 0 retrieved-bytes 0)
  82.         (setq statblob (vm-pop-start-status-timer))
  83.         (vm-set-pop-stat-x-box statblob popdrop)
  84.         (vm-set-pop-stat-x-maxmsg statblob mailbox-count)
  85.         (while (and (<= n mailbox-count)
  86.             (or (not (natnump m-per-session))
  87.                 (< retrieved m-per-session))
  88.             (or (not (natnump b-per-session))
  89.                 (< retrieved-bytes b-per-session)))
  90.           (catch 'skip
  91.         (vm-set-pop-stat-x-currmsg statblob n)
  92.         (if can-uidl
  93.             (condition-case nil
  94.             (let (list)
  95.               (vm-pop-send-command process (format "UIDL %d" n))
  96.               (setq response (vm-pop-read-response process t))
  97.               (if (null response)
  98.                   (signal 'vm-cant-uidl nil))
  99.               (setq list (vm-parse response "\\([\041-\176]+\\) *")
  100.                 uidl (nth 2 list))
  101.               (if (null uidl)
  102.                   (signal 'vm-cant-uidl nil))
  103.               (setcar msgid uidl)
  104.               (if (member msgid pop-retrieved-messages)
  105.                   (progn
  106.                 (if vm-pop-ok-to-ask
  107.                     (message
  108.                      "Skipping message %d (of %d) from %s (retrieved already)..."
  109.                      n mailbox-count popdrop))
  110.                 (throw 'skip t))))
  111.               (vm-cant-uidl
  112.                ;; something failed, so UIDL must not be working.
  113.                ;; note that fact and carry on.
  114.                (setq can-uidl nil
  115.                  msgid nil))))
  116.         (vm-pop-send-command process (format "LIST %d" n))
  117.         (setq message-size (vm-pop-read-list-response process))
  118.         (vm-set-pop-stat-x-need statblob message-size)
  119.         (if (and (integerp vm-pop-max-message-size)
  120.              (> message-size vm-pop-max-message-size)
  121.              (progn
  122.                (setq response
  123.                  (if vm-pop-ok-to-ask
  124.                      (vm-pop-ask-about-large-message
  125.                       process message-size n)
  126.                    'skip))
  127.                (not (eq response 'retrieve))))
  128.             (progn
  129.               (if (eq response 'delete)
  130.               (progn
  131.                 (message "Deleting message %d..." n)
  132.                 (vm-pop-send-command process (format "DELE %d" n))
  133.                 (and (null (vm-pop-read-response process))
  134.                  (throw 'done (not (equal retrieved 0)))))
  135.             (if vm-pop-ok-to-ask
  136.                 (message "Skipping message %d..." n)
  137.               (message
  138.                "Skipping message %d in %s, too large (%d > %d)..."
  139.                n popdrop message-size vm-pop-max-message-size)))
  140.               (throw 'skip t)))
  141.         (message "Retrieving message %d (of %d) from %s..."
  142.              n mailbox-count popdrop)
  143.         (vm-pop-send-command process (format "RETR %d" n))
  144.         (and (null (vm-pop-read-response process))
  145.              (throw 'done (not (equal retrieved 0))))
  146.         (and (null (vm-pop-retrieve-to-crashbox process destination
  147.                             statblob))
  148.              (throw 'done (not (equal retrieved 0))))
  149.         (vm-increment retrieved)
  150.         (and b-per-session
  151.              (setq retrieved-bytes (+ retrieved-bytes message-size)))
  152.         (if (and (not auto-expunge) msgid)
  153.             (setq pop-retrieved-messages
  154.               (cons (copy-sequence msgid)
  155.                 pop-retrieved-messages))
  156.           ;; Either the user doesn't want the messages
  157.           ;; kept in the mailbox or there's no UIDL
  158.           ;; support so there's no way to remember what
  159.           ;; messages we've retrieved.  Delete the
  160.           ;; message now.
  161.           (vm-pop-send-command process (format "DELE %d" n))
  162.           ;; DELE can't fail but Emacs or this code might
  163.           ;; blow a gasket and spew filth down the
  164.           ;; connection, so...
  165.           (and (null (vm-pop-read-response process))
  166.                (throw 'done (not (equal retrieved 0))))))
  167.           (vm-increment n))
  168.          (not (equal retrieved 0)) ))
  169.       (setq vm-pop-retrieved-messages pop-retrieved-messages)
  170.       (and statblob (vm-pop-stop-status-timer statblob))
  171.       (if process
  172.       (vm-pop-end-session process)))))
  173.  
  174. (defun vm-pop-check-mail (source)
  175.   (let ((process nil)
  176.     (handler (and (fboundp 'find-file-name-handler)
  177.               (condition-case ()
  178.               (find-file-name-handler source 'vm-pop-check-mail)
  179.             (wrong-number-of-arguments
  180.              (find-file-name-handler source)))))
  181.     response)
  182.     (unwind-protect
  183.     (save-excursion
  184.       (catch 'done
  185.         (if handler
  186.         (throw 'done
  187.                (funcall handler 'vm-pop-check-mail source)))
  188.         (setq process (vm-pop-make-session source))
  189.         (or process (throw 'done nil))
  190.         (set-buffer (process-buffer process))
  191.         (vm-pop-send-command process "STAT")
  192.         (setq response (vm-pop-read-stat-response process))
  193.         (if (null response)
  194.         nil
  195.           (not (equal 0 (car response))))))
  196.       (and process (vm-pop-end-session process)))))
  197.  
  198. (defun vm-expunge-pop-messages ()
  199.   "Deletes all messages from POP mailbox that have already been retrieved
  200. into the current folder.  VM sends POP DELE commands to all the
  201. relevant POP servers to remove the messages."
  202.   (interactive)
  203.   (vm-follow-summary-cursor)
  204.   (vm-select-folder-buffer)
  205.   (vm-check-for-killed-summary)
  206.   (vm-error-if-virtual-folder)
  207.   (let ((process nil)
  208.     (source nil)
  209.     (trouble nil)
  210.     (delete-count 0)
  211.     (vm-block-new-mail t)
  212.     (vm-pop-ok-to-ask t)
  213.     popdrop    uidl-alist data    mp match)
  214.     (unwind-protect
  215.     (save-excursion
  216.       (setq vm-pop-retrieved-messages
  217.         (sort vm-pop-retrieved-messages
  218.               (function (lambda (a b)
  219.                   (cond ((string-lessp (nth 1 a) (nth 1 b)) t)
  220.                     ((string-lessp (nth 1 b)
  221.                                (nth 1 a))
  222.                      nil)
  223.                     ((string-lessp (car a) (car b)) t)
  224.                     (t nil))))))
  225.       (setq mp vm-pop-retrieved-messages)
  226.       (while mp
  227.         (condition-case nil
  228.         (catch 'skip
  229.           (setq data (car mp))
  230.           (if (not (equal source (nth 1 data)))
  231.               (progn
  232.             (if process
  233.                 (progn
  234.                  (vm-pop-end-session process)
  235.                  (setq process nil)))
  236.             (setq source (nth 1 data))
  237.             (setq popdrop (vm-safe-popdrop-string source))
  238.             (condition-case nil
  239.                 (progn
  240.                   (message "Opening POP session to %s..." popdrop)
  241.                   (setq process (vm-pop-make-session source))
  242.                   (if (null process)
  243.                   (signal 'error nil))
  244.                   (message "Expunging messages in %s..." popdrop))
  245.               (error
  246.                (message
  247.                 "Couldn't open POP session to %s, skipping..."
  248.                 popdrop)
  249.                (setq trouble (cons popdrop trouble))
  250.                (sleep-for 2)
  251.                (while (equal (nth 1 (car mp)) source)
  252.                  (setq mp (cdr mp)))
  253.                (throw 'skip t)))
  254.             (set-buffer (process-buffer process))
  255.             (vm-pop-send-command process "UIDL")
  256.             (setq uidl-alist
  257.                   (vm-pop-read-uidl-long-response process))
  258.             (if (null uidl-alist)
  259.                 (signal 'vm-uidl-failed nil))))
  260.           (if (setq match (rassoc (car data) uidl-alist))
  261.               (progn
  262.             (vm-pop-send-command process
  263.                          (format "DELE %s" (car match)))
  264.             (if (null (vm-pop-read-response process))
  265.                 (signal 'vm-dele-failed nil))
  266.             (vm-increment delete-count)))
  267.           (setq mp (cdr mp)))
  268.           (vm-dele-failed
  269.            (message "DELE %s failed on %s, skipping rest of mailbox..."
  270.             (car match) popdrop)
  271.            (setq trouble (cons popdrop trouble))
  272.            (sleep-for 2)
  273.            (while (equal (nth 1 (car mp)) source)
  274.          (setq mp (cdr mp)))
  275.            (throw 'skip t))
  276.           (vm-uidl-failed
  277.            (message "UIDL %s failed on %s, skipping this mailbox..."
  278.             (car match) popdrop)
  279.            (setq trouble (cons popdrop trouble))
  280.            (sleep-for 2)
  281.            (while (equal (nth 1 (car mp)) source)
  282.          (setq mp (cdr mp)))
  283.            (throw 'skip t))))
  284.       (if trouble
  285.           (progn
  286.         (set-buffer (get-buffer-create "*POP Expunge Trouble*"))
  287.         (erase-buffer)
  288.         (insert (format "%s POP message%s expunged.\n\n"
  289.                 (if (zerop delete-count) "No" delete-count)
  290.                 (if (= delete-count 1) "" "s")))
  291.         (insert "VM had problems expunging message from:\n")
  292.         (nreverse trouble)
  293.         (setq mp trouble)
  294.         (while mp
  295.           (insert "   " (car mp) "\n")
  296.           (setq mp (cdr mp)))
  297.         (setq buffer-read-only t)
  298.         (display-buffer (current-buffer)))
  299.         (message "%s POP message%s expunged."
  300.              (if (zerop delete-count) "No" delete-count)
  301.              (if (= delete-count 1) "" "s"))))
  302.       (and process (vm-pop-end-session process)))
  303.     (or trouble (setq vm-pop-retrieved-messages nil))))
  304.  
  305. (defun vm-pop-make-session (source)
  306.   (let ((process-to-shutdown nil)
  307.     process
  308.     (popdrop (vm-safe-popdrop-string source))
  309.     (coding-system-for-read 'binary)
  310.     (coding-system-for-write 'binary)
  311.     greeting timestamp
  312.     host port auth user pass source-list process-buffer source-nopwd)
  313.     (unwind-protect
  314.     (catch 'done
  315.       ;; parse the maildrop
  316.       (setq source-list (vm-parse source "\\([^:]+\\):?")
  317.         host (nth 0 source-list)
  318.         port (nth 1 source-list)
  319.         auth (nth 2 source-list)
  320.         user (nth 3 source-list)
  321.         pass (nth 4 source-list)
  322.         source-nopwd (vm-popdrop-sans-password source))
  323.       ;; carp if parts are missing
  324.       (if (null host)
  325.           (error "No host in POP maildrop specification, \"%s\""
  326.              source))
  327.       (if (null port)
  328.           (error "No port in POP maildrop specification, \"%s\""
  329.              source))
  330.       (if (string-match "^[0-9]+$" port)
  331.           (setq port (string-to-int port)))
  332.       (if (null auth)
  333.           (error
  334.            "No authentication method in POP maildrop specification, \"%s\""
  335.            source))
  336.       (if (null user)
  337.           (error "No user in POP maildrop specification, \"%s\""
  338.              source))
  339.       (if (null pass)
  340.           (error "No password in POP maildrop specification, \"%s\""
  341.              source))
  342.       (if (equal pass "*")
  343.           (progn
  344.         (setq pass (car (cdr (assoc source-nopwd vm-pop-passwords))))
  345.         (if (null pass)
  346.             (if (null vm-pop-ok-to-ask)
  347.             (progn (message "Need password for %s" popdrop)
  348.                    (throw 'done nil))
  349.               (setq pass
  350.                 (vm-read-password
  351.                  (format "POP password for %s: "
  352.                      popdrop)))))))
  353.       ;; save the password for the sake of
  354.       ;; vm-expunge-pop-passwords, which passes password-less
  355.       ;; popdrop specifications to vm-make-pop-session.
  356.       (if (null (assoc source-nopwd vm-pop-passwords))
  357.           (setq vm-pop-passwords (cons (list source-nopwd pass)
  358.                        vm-pop-passwords)))
  359.       ;; get the trace buffer
  360.       (setq process-buffer
  361.         (get-buffer-create (format "trace of POP session to %s" host)))
  362.       ;; Tell XEmacs/MULE not to mess with the text.
  363.       (and vm-xemacs-mule-p
  364.            (set-buffer-file-coding-system 'binary t))
  365.       ;; clear the trace buffer of old output
  366.       (save-excursion
  367.         (set-buffer process-buffer)
  368.         (buffer-disable-undo process-buffer)
  369.         (erase-buffer))
  370.       ;; open the connection to the server
  371.       (setq process (open-network-stream "POP" process-buffer host port))
  372.       (and (null process) (throw 'done nil))
  373.       (process-kill-without-query process)
  374.       (save-excursion
  375.         (set-buffer process-buffer)
  376.         (make-local-variable 'vm-pop-read-point)
  377.         (setq vm-pop-read-point (point-min))
  378.         (if (null (setq greeting (vm-pop-read-response process t)))
  379.         (progn (delete-process process)
  380.                (throw 'done nil)))
  381.         (setq process-to-shutdown process)
  382.         ;; authentication
  383.         (cond ((equal auth "pass")
  384.            (vm-pop-send-command process (format "USER %s" user))
  385.            (and (null (vm-pop-read-response process))
  386.             (throw 'done nil))
  387.            (vm-pop-send-command process (format "PASS %s" pass))
  388.            (if (null (vm-pop-read-response process))
  389.                (progn
  390.              (setq vm-pop-passwords
  391.                    (delete (list source-nopwd pass)
  392.                        vm-pop-passwords))
  393.              (message "POP password for %s incorrect" popdrop)
  394.              (sleep-for 2)
  395.              (throw 'done nil))))
  396.           ((equal auth "rpop")
  397.            (vm-pop-send-command process (format "USER %s" user))
  398.            (and (null (vm-pop-read-response process))
  399.             (throw 'done nil))
  400.            (vm-pop-send-command process (format "RPOP %s" pass))
  401.            (and (null (vm-pop-read-response process))
  402.             (throw 'done nil)))
  403.           ((equal auth "apop")
  404.            (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)")
  405.              timestamp (car timestamp))
  406.            (if (null timestamp)
  407.                (progn
  408.              (goto-char (point-max))
  409.    (insert-before-markers "<<< ooops, no timestamp found in greeting! >>>\n")
  410.              (throw 'done nil)))
  411.            (vm-pop-send-command
  412.             process
  413.             (format "APOP %s %s"
  414.                 user
  415.                 (vm-pop-md5 (concat timestamp pass))))
  416.            (and (null (vm-pop-read-response process))
  417.             (throw 'done nil)))
  418.           (t (error "Don't know how to authenticate using %s" auth)))
  419.         (setq process-to-shutdown nil)
  420.         process ))
  421.       (if process-to-shutdown
  422.       (vm-pop-end-session process-to-shutdown)))))
  423.  
  424. (defun vm-pop-end-session (process)
  425.   (save-excursion
  426.     (set-buffer (process-buffer process))
  427.     (vm-pop-send-command process "QUIT")
  428.     ;; we don't care about the response
  429.     ;;(vm-pop-read-response process)
  430.     (if (fboundp 'add-async-timeout)
  431.     (add-async-timeout 2 'delete-process process)
  432.       (run-at-time 2 nil 'delete-process process))))
  433.  
  434. (defun vm-pop-stat-timer (o) (aref o 0))
  435. (defun vm-pop-stat-x-box (o) (aref o 1))
  436. (defun vm-pop-stat-x-currmsg (o) (aref o 2))
  437. (defun vm-pop-stat-x-maxmsg (o) (aref o 3))
  438. (defun vm-pop-stat-x-got (o) (aref o 4))
  439. (defun vm-pop-stat-x-need (o) (aref o 5))
  440. (defun vm-pop-stat-y-box (o) (aref o 6))
  441. (defun vm-pop-stat-y-currmsg (o) (aref o 7))
  442. (defun vm-pop-stat-y-maxmsg (o) (aref o 8))
  443. (defun vm-pop-stat-y-got (o) (aref o 9))
  444. (defun vm-pop-stat-y-need (o) (aref o 10))
  445.  
  446. (defun vm-set-pop-stat-timer (o val) (aset o 0 val))
  447. (defun vm-set-pop-stat-x-box (o val) (aset o 1 val))
  448. (defun vm-set-pop-stat-x-currmsg (o val) (aset o 2 val))
  449. (defun vm-set-pop-stat-x-maxmsg (o val) (aset o 3 val))
  450. (defun vm-set-pop-stat-x-got (o val) (aset o 4 val))
  451. (defun vm-set-pop-stat-x-need (o val) (aset o 5 val))
  452. (defun vm-set-pop-stat-y-box (o val) (aset o 6 val))
  453. (defun vm-set-pop-stat-y-currmsg (o val) (aset o 7 val))
  454. (defun vm-set-pop-stat-y-maxmsg (o val) (aset o 8 val))
  455. (defun vm-set-pop-stat-y-got (o val) (aset o 9 val))
  456. (defun vm-set-pop-stat-y-need (o val) (aset o 10 val))
  457.  
  458. (defun vm-pop-start-status-timer ()
  459.   (let ((blob (make-vector 11 nil))
  460.     timer)
  461.     (setq timer (add-timeout 5 'vm-pop-report-retrieval-status blob 5))
  462.     (vm-set-pop-stat-timer blob timer)
  463.     blob ))
  464.  
  465. (defun vm-pop-stop-status-timer (status-blob)
  466.   (if (fboundp 'disable-timeout)
  467.       (disable-timeout (vm-pop-stat-timer status-blob))
  468.     (cancel-timer (vm-pop-stat-timer status-blob))))
  469.  
  470. (defun vm-pop-report-retrieval-status (o)
  471.   (cond ((null (vm-pop-stat-x-got o)) t)
  472.     ;; should not be possible, but better safe...
  473.     ((not (eq (vm-pop-stat-x-box o) (vm-pop-stat-y-box o))) t)
  474.     ((not (eq (vm-pop-stat-x-currmsg o) (vm-pop-stat-y-currmsg o))) t)
  475.     (t (message "Retrieving message %d (of %d) from %s, %s..."
  476.             (vm-pop-stat-x-currmsg o)
  477.             (vm-pop-stat-x-maxmsg o)
  478.             (vm-pop-stat-x-box o)
  479.             (format "%d%s of %d%s"
  480.                 (vm-pop-stat-x-got o)
  481.                 (if (> (vm-pop-stat-x-got o)
  482.                    (vm-pop-stat-x-need o))
  483.                 "!"
  484.                   "")
  485.                 (vm-pop-stat-x-need o)
  486.                 (if (eq (vm-pop-stat-x-got o)
  487.                     (vm-pop-stat-y-got o))
  488.                 " (stalled)"
  489.                   "")))))
  490.   (vm-set-pop-stat-y-box o (vm-pop-stat-x-box o))
  491.   (vm-set-pop-stat-y-currmsg o (vm-pop-stat-x-currmsg o))
  492.   (vm-set-pop-stat-y-maxmsg o (vm-pop-stat-x-maxmsg o))
  493.   (vm-set-pop-stat-y-got o (vm-pop-stat-x-got o))
  494.   (vm-set-pop-stat-y-need o (vm-pop-stat-x-need o)))
  495.  
  496. (defun vm-pop-send-command (process command)
  497.   (goto-char (point-max))
  498.   (if (= (aref command 0) ?P)
  499.       (insert-before-markers "PASS <omitted>\r\n")
  500.     (insert-before-markers command "\r\n"))
  501.   (setq vm-pop-read-point (point))
  502.   (process-send-string process command)
  503.   (process-send-string process "\r\n"))
  504.  
  505. (defun vm-pop-read-response (process &optional return-response-string)
  506.   (let ((case-fold-search nil)
  507.      match-end)
  508.     (goto-char vm-pop-read-point)
  509.     (while (not (search-forward "\r\n" nil t))
  510.       (accept-process-output process)
  511.       (goto-char vm-pop-read-point))
  512.     (setq match-end (point))
  513.     (goto-char vm-pop-read-point)
  514.     (if (not (looking-at "+OK"))
  515.     (progn (setq vm-pop-read-point match-end) nil)
  516.       (setq vm-pop-read-point match-end)
  517.       (if return-response-string
  518.       (buffer-substring (point) match-end)
  519.     t ))))
  520.  
  521. (defun vm-pop-read-past-dot-sentinel-line (process)
  522.   (let ((case-fold-search nil))
  523.     (goto-char vm-pop-read-point)
  524.     (while (not (re-search-forward "^\\.\r\n" nil 0))
  525.       (beginning-of-line)
  526.       ;; save-excursion doesn't work right
  527.       (let ((opoint (point)))
  528.     (accept-process-output process)
  529.     (goto-char opoint)))
  530.     (setq vm-pop-read-point (point))))
  531.  
  532. (defun vm-pop-read-stat-response (process)
  533.   (let ((response (vm-pop-read-response process t))
  534.     list)
  535.     (setq list (vm-parse response "\\([^ ]+\\) *"))
  536.     (list (string-to-int (nth 1 list)) (string-to-int (nth 2 list)))))
  537.  
  538. (defun vm-pop-read-list-response (process)
  539.   (let ((response (vm-pop-read-response process t)))
  540.     (string-to-int (nth 2 (vm-parse response "\\([^ ]+\\) *")))))
  541.  
  542. (defun vm-pop-read-uidl-long-response (process)
  543.   (let ((start vm-pop-read-point)
  544.     (list nil)
  545.     n uidl)
  546.     (catch 'done
  547.       (goto-char start)
  548.       (while (not (re-search-forward "^\\.\r\n" nil 0))
  549.     (beginning-of-line)
  550.     ;; save-excursion doesn't work right
  551.     (let ((opoint (point)))
  552.       (accept-process-output process)
  553.       (goto-char opoint)))
  554.       (setq vm-pop-read-point (point-marker))
  555.       (goto-char start)
  556.       ;; no uidl support, bail.
  557.       (if (not (looking-at "\\+OK"))
  558.       (throw 'done nil))
  559.       (forward-line 1)
  560.       (while (not (eq (char-after (point)) ?.))
  561.     ;; not loking at a number, bail.
  562.     (if (not (looking-at "[0-9]"))
  563.         (throw 'done nil))
  564.     (setq n (int-to-string (read (current-buffer))))
  565.     (skip-chars-forward " ")
  566.     (setq start (point))
  567.     (skip-chars-forward "\041-\176")
  568.     ;; no tag after the message number, bail.
  569.     (if (= start (point))
  570.         (throw 'done nil))
  571.     (setq uidl (buffer-substring start (point)))
  572.     (setq list (cons (cons n uidl) list))
  573.     (forward-line 1))
  574.       ;; returning nil means the uidl command failed so don't
  575.       ;; return nil if there aren't any messages.
  576.       (if (null list)
  577.       (cons nil nil)
  578.     list ))))
  579.  
  580. (defun vm-pop-ask-about-large-message (process size n)
  581.   (let ((work-buffer nil)
  582.     (pop-buffer (current-buffer))
  583.     start end)
  584.     (unwind-protect
  585.     (save-excursion
  586.       (save-window-excursion
  587.         (vm-pop-send-command process (format "TOP %d %d" n 0))
  588.         (if (vm-pop-read-response process)
  589.         (progn
  590.           (setq start vm-pop-read-point)
  591.           (vm-pop-read-past-dot-sentinel-line process)
  592.           (setq end vm-pop-read-point)
  593.           (setq work-buffer (generate-new-buffer "*pop-glop*"))
  594.           (set-buffer work-buffer)
  595.           (insert-buffer-substring pop-buffer start end)
  596.           (forward-line -1)
  597.           (delete-region (point) (point-max))
  598.           (vm-pop-cleanup-region (point-min) (point-max))
  599.           (vm-display-buffer work-buffer)
  600.           (setq minibuffer-scroll-window (selected-window))
  601.           (goto-char (point-min))
  602.           (if (re-search-forward "^Received:" nil t)
  603.               (progn
  604.             (goto-char (match-beginning 0))
  605.             (vm-reorder-message-headers
  606.              nil vm-visible-headers
  607.              vm-invisible-header-regexp)))
  608.           (set-window-point (selected-window) (point))))
  609.         (if (y-or-n-p (format "Message %d, size = %d, retrieve? " n size))
  610.         'retrieve
  611.           (if (y-or-n-p (format "Delete message %d from popdrop? " n size))
  612.           'delete
  613.         'skip))))
  614.       (and work-buffer (kill-buffer work-buffer)))))
  615.  
  616. (defun vm-pop-retrieve-to-crashbox (process crash statblob)
  617.   (let ((start vm-pop-read-point) end)
  618.     (goto-char start)
  619.     (vm-set-pop-stat-x-got statblob 0)
  620.     (while (not (re-search-forward "^\\.\r\n" nil 0))
  621.       (beginning-of-line)
  622.       ;; save-excursion doesn't work right
  623.       (let* ((opoint (point))
  624.          (func
  625.           (function
  626.            (lambda (beg end len)
  627.          (if vm-pop-read-point
  628.              (progn
  629.                (vm-set-pop-stat-x-got statblob (- end start))
  630.                (if (zerop (% (random) 10))
  631.                (vm-pop-report-retrieval-status statblob)))))))
  632.          (after-change-functions (cons func after-change-functions)))
  633.     (accept-process-output process)
  634.     (goto-char opoint)))
  635.     (vm-set-pop-stat-x-got statblob nil)
  636.     (setq vm-pop-read-point (point-marker))
  637.     (goto-char (match-beginning 0))
  638.     (setq end (point-marker))
  639.     (vm-pop-cleanup-region start end)
  640.     ;; Some POP servers strip leading and trailing message
  641.     ;; separators, some don't.  Figure out what kind we're
  642.     ;; talking to and do the right thing.
  643.     (if (eq (vm-get-folder-type nil start end) 'unknown)
  644.     (progn
  645.       (vm-munge-message-separators vm-folder-type start end)
  646.       (goto-char start)
  647.       ;; avoid the consing and stat() call for all but babyl
  648.       ;; files, since this will probably slow things down.
  649.       ;; only babyl files have the folder header, and we
  650.       ;; should only insert it if the crash box is empty.
  651.       (if (and (eq vm-folder-type 'babyl)
  652.            (let ((attrs (file-attributes crash)))
  653.              (or (null attrs) (equal 0 (nth 7 attrs)))))
  654.           (let ((opoint (point)))
  655.         (vm-convert-folder-header nil vm-folder-type)
  656.         ;; if start is a marker, then it was moved
  657.         ;; forward by the insertion.  restore it.
  658.         (setq start opoint)
  659.         (goto-char start)
  660.         (vm-skip-past-folder-header)))
  661.       (insert (vm-leading-message-separator))
  662.       ;; this will not find the trailing message separator but
  663.       ;; for the Content-Length stuff counting from eob is
  664.       ;; the same thing in this case.
  665.       (vm-convert-folder-type-headers nil vm-folder-type)
  666.       (goto-char end)
  667.       (insert-before-markers (vm-trailing-message-separator))))
  668.     ;; Set file type to binary for DOS/Windows.  I don't know if
  669.     ;; this is correct to do or not; it depends on whether the
  670.     ;; the CRLF or the LF newline convention is used on the inbox
  671.     ;; associated with this crashbox.  This setting assumes the LF
  672.     ;; newline convention is used.
  673.     (let ((buffer-file-type t))
  674.       (write-region start end crash t 0))
  675.     (delete-region start end)
  676.     t ))
  677.  
  678. (defun vm-pop-cleanup-region (start end)
  679.   (if (> (- end start) 30000)
  680.       (message "CRLF conversion and char unstuffing..."))
  681.   (setq end (vm-marker end))
  682.   (save-excursion
  683.     (goto-char start)
  684.     ;; CRLF -> LF
  685.     (while (and (< (point) end) (search-forward "\r\n"  end t))
  686.       (replace-match "\n" t t))
  687.     (goto-char start)
  688.     ;; chop leading dots
  689.     (while (and (< (point) end) (re-search-forward "^\\."  end t))
  690.       (replace-match "" t t)
  691.       (forward-char)))
  692.   (if (> (- end start) 30000)
  693.       (message "CRLF conversion and char unstuffing... done"))
  694.   (set-marker end nil))
  695.  
  696. (defun vm-pop-md5 (string)
  697.   (let ((buffer nil))
  698.     (unwind-protect
  699.     (save-excursion
  700.       (setq buffer (generate-new-buffer "*vm-work*"))
  701.       (set-buffer buffer)
  702.       (insert string)
  703.       (call-process-region (point-min) (point-max)
  704.                    "/bin/sh" t buffer nil
  705.                    shell-command-switch vm-pop-md5-program)
  706.       ;; MD5 digest is 32 chars long
  707.       ;; mddriver adds a newline to make neaten output for tty
  708.       ;; viewing, make sure we leave it behind.
  709.       (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32)))
  710.       (and buffer (kill-buffer buffer)))))
  711.  
  712. (defun vm-popdrop-sans-password (source)
  713.   (let (source-list)
  714.     (setq source-list (vm-parse source "\\([^:]+\\):?"))
  715.     (concat (nth 0 source-list) ":"
  716.         (nth 1 source-list) ":"
  717.         (nth 2 source-list) ":"
  718.         (nth 3 source-list) ":*")))
  719.